home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 4 / Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso / Pearls / dev / Language / CLisp / backquot.lsp < prev    next >
Lisp/Scheme  |  1996-04-15  |  13KB  |  314 lines
  1. ;;;; Backquote-Readmacro
  2. ;;;; Michael Stoll
  3. ;;;; umgeschrieben im Juli/August von Bruno Haible
  4. ;;;; rekursives Backquote 16.-17.8.1989
  5. ;;;; an die übliche Semantik für rekursives Backquote angepaßt am 24.5.1992
  6.  
  7. (in-package "SYSTEM")
  8.  
  9. (proclaim '(special *backquote-level*))
  10. ; NIL oder Anzahl der erlaubten Kommata
  11. ; Wird beim Top-Level-Einsprung in den Reader an NIL gebunden.
  12.  
  13. (proclaim '(special *nsplice-fun*))
  14. (setq *nsplice-fun* 'NCONC) ; Funktion, die ein NSPLICE ausführt
  15. ; (Wird an 'APPEND gebunden für die Produktion der Ausgabe-Form in
  16. ; verschachtelten Backquotes.)
  17.  
  18. ; Bug: Bei verschachtelten Backquotes werden manche Teilformen mehrfach
  19. ; ausgewertet (nämlich z.B. in der ersten Evaluation Formen, die fürs
  20. ; Ausgeben vor der zweiten Evaluation nötig sind) und sollten deshalb
  21. ; seiteneffektfrei sein.
  22.  
  23. (defun \`-reader (stream char)
  24.   (declare (ignore char))
  25.   (let* ((*backquote-level* (1+ (or *backquote-level* 0)))
  26.          (skel (read stream t nil t))
  27.          (form (list 'BACKQUOTE
  28.                      (remove-backquote-third skel)
  29.                      (backquote-1 (unquote-level skel))
  30.         ))     )
  31.     (when (= *backquote-level* 1) (setq form (elim-unquote-dummy form)))
  32.     form
  33. ) )
  34.  
  35. (defun \,-reader (stream char &aux (c (peek-char nil stream)))
  36.   (declare (ignore char))
  37.   (cond ((null *backquote-level*)
  38.          (error-of-type 'error
  39.            #L{DEUTSCH "~S: Komma darf nur innerhalb von Backquote auftreten."
  40.             ENGLISH "~S: comma is illegal outside of backquote"
  41.             FRANCAIS "~S : Une virgule ne peut apparaître qu'à l'intérieur d'un «backquote»."}
  42.            'read
  43.         ))
  44.         ((zerop *backquote-level*)
  45.          (error-of-type 'error
  46.            #L{DEUTSCH "~S: Es dürfen nicht mehr Kommata als Backquotes auftreten."
  47.             ENGLISH "~S: more commas out than backquotes in, is illegal"
  48.             FRANCAIS "~S : Il ne peut y avoir plus de virgules que de «backquote»."}
  49.            'read
  50.         ))
  51.         (t (let ((*backquote-level* (1- *backquote-level*)))
  52.              (cond ((eql c #\@)
  53.                     (read-char stream)
  54.                     (list 'SPLICE (list 'UNQUOTE (read stream t nil t)))
  55.                    )
  56.                    ((eql c #\.)
  57.                     (read-char stream)
  58.                     (list 'NSPLICE (list 'UNQUOTE (read stream t nil t)))
  59.                    )
  60.                    (t (list 'UNQUOTE (read stream t nil t)))
  61. ) )     )  ) )
  62.  
  63. ;(set-macro-character #\` #'\`-reader)
  64. ;(set-macro-character #\, #'\,-reader)
  65.  
  66. ; Ausgabe von ...                              als ...
  67. ; (backquote original-form [expanded-form])    `original-form
  68. ; (splice (unquote form))                      ,@form
  69. ; (splice form)                                ,@'form
  70. ; (nsplice (unquote form))                     ,.form
  71. ; (nsplice form)                               ,.'form
  72. ; (unquote form)                               ,form
  73.  
  74. ;(defmacro backquote (original-form expanded-form)
  75. ;  (declare (ignore original-form))
  76. ;  expanded-form
  77. ;)
  78.  
  79. (defun remove-backquote-third (skel)
  80.   (cond ((atom skel)
  81.          (if (simple-vector-p skel)
  82.            (map 'vector #'remove-backquote-third skel)
  83.            skel
  84.         ))
  85.         ((and (eq (car skel) 'BACKQUOTE) (consp (cdr skel)))
  86.          (list 'BACKQUOTE (second skel)) ; ohne drittes Element der Liste
  87.         )
  88.         (t (cons (remove-backquote-third (car skel))
  89.                  (remove-backquote-third (cdr skel))
  90. ) )     )  )
  91.  
  92. ; ersetzt UNQUOTE-DUMMY durch UNQUOTE.
  93. (defun elim-unquote-dummy (skel)
  94.   (if (atom skel)
  95.     (cond ((eq skel 'UNQUOTE-DUMMY) 'UNQUOTE)
  96.           ((simple-vector-p skel) (map 'vector #'elim-unquote-dummy skel))
  97.           (t skel)
  98.     )
  99.     (let* ((car (car skel)) (newcar (elim-unquote-dummy car))
  100.            (cdr (cdr skel)) (newcdr (elim-unquote-dummy cdr)))
  101.       (if (and (eq car newcar) (eq cdr newcdr))
  102.         skel
  103.         (cons newcar newcdr)
  104. ) ) ) )
  105.  
  106. ;; wandelt im "Skelett" skel alle UNQUOTEs der Stufe level+1 (d.h. innerhalb
  107. ;; von level-fachem UNQUOTE) in UNQUOTE-VALUE um.
  108. (defun unquote-level (skel &optional (level 0))
  109.   (if (atom skel)
  110.     (if (simple-vector-p skel)
  111.       (map 'vector #'(lambda (subskel) (unquote-level subskel level)) skel)
  112.       skel
  113.     )
  114.     ; skel ist ein Cons
  115.     (cond ((and (eq (first skel) 'UNQUOTE) (consp (rest skel)))
  116.            (if (zerop level)
  117.              (list 'UNQUOTE-VALUE (second skel))
  118.              (let ((weiteres (unquote-level (second skel) (1- level))))
  119.                ; Vereinfache (UNQUOTE weiteres):
  120.                (if (and (consp weiteres) (eq (car weiteres) 'QUOTE)
  121.                         (consp (second weiteres))
  122.                         (eq (car (second weiteres)) 'UNQUOTE-VALUE)
  123.                    )
  124.                  ; (UNQUOTE (QUOTE (UNQUOTE-VALUE ...))) -> (UNQUOTE-VALUE ...)
  125.                  (second weiteres)
  126.                  (list 'UNQUOTE weiteres)
  127.           )) ) )
  128.           ((and (eq (first skel) 'BACKQUOTE) (consp (rest skel)))
  129.            (list* 'BACKQUOTE
  130.                   (unquote-level (second skel) (1+ level))
  131.                   (if (consp (cddr skel))
  132.                     (list (unquote-level (third skel) level))
  133.                     nil
  134.           ))      )
  135.           (t ; CAR-CDR-Rekursion
  136.             (cons (unquote-level (car skel) level)
  137.                   (unquote-level (cdr skel) level)
  138. ) ) )     ) )
  139.  
  140. ;; stellt fest, ob eine Form zu mehreren expandieren kann.
  141. (defun splicing-p (skel)
  142.   (and (consp skel)
  143.        (let ((h (first skel))) (or (eq h 'splice) (eq h 'nsplice)))
  144. ) )
  145.  
  146. ;; wandelt "Skelett" skel (mit UNQUOTE-VALUEs etc.) in passenden Code um.
  147. (defun backquote-1 (skel)
  148.   (if (atom skel)
  149.     (cond ((or (and (symbolp skel) (constantp skel) (eq skel (symbol-value skel)))
  150.                (numberp skel)
  151.                (stringp skel)
  152.                (bit-vector-p skel)
  153.            )
  154.            ; Konstanten, die zu sich selbst evaluieren, bleiben unverändert
  155.            skel
  156.           )
  157.           ((simple-vector-p skel)
  158.            ; Vektoren:
  159.            ; #(... item ...) -> (VECTOR ... item ...)
  160.            ; #(... ,@form ...) ->
  161.            ;   (MULTIPLE-VALUE-CALL #'VECTOR ... (VALUES-LIST form) ...)
  162.            (if (some #'splicing-p skel)
  163.              (list* 'MULTIPLE-VALUE-CALL
  164.                     '(FUNCTION VECTOR)
  165.                     (map 'list
  166.                          #'(lambda (subskel)
  167.                              (if (splicing-p subskel)
  168.                                (if (and (consp (second subskel))
  169.                                         (eq (first (second subskel)) 'UNQUOTE-VALUE)
  170.                                    )
  171.                                  (list 'VALUES-LIST (backquote-1 (second subskel)))
  172.                                  ; SPLICE bzw. NSPLICE für später aufheben
  173.                                  (backquote-cons (backquote-1 (first subskel))
  174.                                                  (backquote-1 (rest subskel))
  175.                                ) )
  176.                                (list 'VALUES (backquote-1 subskel))
  177.                            ) )
  178.                          skel
  179.              )      )
  180.              (let ((einzelne (map 'list #'backquote-1 skel)))
  181.                (if (every #'constantp einzelne)
  182.                  ; alle Teile konstant -> sofort zusammensetzen
  183.                  (list 'QUOTE (map 'vector #'eval einzelne))
  184.                  (cons 'VECTOR einzelne)
  185.              ) )
  186.           ))
  187.           (t
  188.            ; sonstige Atome A in 'A umwandeln
  189.            (list 'QUOTE skel)
  190.     )     )
  191.     (cond ((eq (first skel) 'unquote-value)
  192.            ; ,form im richtigen Level wird zu form
  193.            (second skel)
  194.           )
  195.           ((eq (first skel) 'splice)
  196.            ; ,@form ist verboten
  197.            (error-of-type 'error
  198.              #L{DEUTSCH "Die Syntax ,@form ist nur innerhalb von Listen erlaubt."
  199.               ENGLISH "The syntax ,@form is valid only in lists"
  200.               FRANCAIS "La syntaxe ,@form n'est permise qu'à l'intérieur d'une liste."}
  201.           ))
  202.           ((eq (first skel) 'nsplice)
  203.            ; ,.form ist verboten
  204.            (error-of-type 'error
  205.              #L{DEUTSCH "Die Syntax ,.form ist nur innerhalb von Listen erlaubt."
  206.               ENGLISH "The syntax ,.form is valid only in lists"
  207.               FRANCAIS "La syntaxe ,.form n'est permise qu'à l'intérieur d'une liste."}
  208.           ))
  209.           ((and (eq (first skel) 'backquote) (consp (rest skel)))
  210.            ; verschachtelte Backquotes
  211.            (list* 'LIST
  212.                   ''BACKQUOTE
  213.                   (let ((*nsplice-fun* 'APPEND)) (backquote-1 (second skel)))
  214.                   (if (consp (cddr skel))
  215.                     (list (backquote-1 (third skel)))
  216.                     nil
  217.           ))      )
  218.           ((and (consp (first skel))
  219.                 (eq (first (first skel)) 'splice)
  220.            )
  221.            ; (  ... ,@EXPR ...  ) behandeln
  222.            (if (and (consp (second (first skel)))
  223.                     (eq (first (second (first skel))) 'UNQUOTE-VALUE)
  224.                )
  225.              (backquote-append (backquote-1 (second (first skel)))
  226.                                (backquote-1 (rest skel))
  227.              )
  228.              ; SPLICE für später aufheben
  229.              (backquote-cons
  230.                (backquote-cons (backquote-1 (first (first skel)))
  231.                                (backquote-1 (rest (first skel)))
  232.                )
  233.                (backquote-1 (rest skel))
  234.           )) )
  235.           ((and (consp (first skel))
  236.                 (eq (first (first skel)) 'nsplice)
  237.            )
  238.            ; (  ... ,.EXPR ...  ) behandeln
  239.            (if (and (consp (second (first skel)))
  240.                     (eq (first (second (first skel))) 'UNQUOTE-VALUE)
  241.                )
  242.              (let ((erstes (backquote-1 (second (first skel))))
  243.                    (weiteres (backquote-1 (rest skel))))
  244.                ; (NCONC erstes weiteres) vereinfachen
  245.                (cond ((null weiteres)
  246.                       ; (NCONC expr NIL) -> (NCONC expr) -> expr
  247.                       (if (splicing-p erstes)
  248.                         (list *nsplice-fun* erstes)
  249.                         erstes
  250.                      ))
  251.                      ((and (consp weiteres) (eq (first weiteres) *nsplice-fun*))
  252.                       ; (NCONC expr (NCONC . rest)) -> (NCONC expr . rest)
  253.                       (list* *nsplice-fun* erstes (rest weiteres)) )
  254.                      (t (list *nsplice-fun* erstes weiteres))
  255.              ) )
  256.              ; NSPLICE für später aufheben
  257.              (backquote-cons
  258.                (backquote-cons (backquote-1 (first (first skel)))
  259.                                (backquote-1 (rest (first skel)))
  260.                )
  261.                (backquote-1 (rest skel))
  262.           )) )
  263.           (t ; sonst CAR und CDR zusammensetzen
  264.              (backquote-cons (backquote-1 (first skel)) (backquote-1 (rest skel)))
  265.           )
  266. ) ) )
  267.  
  268. ; Liefert die Form, die das Append-Ergebnis der Formen erstes und weiteres
  269. ; ergibt.
  270. (defun backquote-append (erstes weiteres)
  271.   ; (APPEND erstes weiteres) vereinfachen
  272.   (cond ((null weiteres)
  273.          ; (APPEND expr NIL) -> (APPEND expr) -> expr
  274.          (if (splicing-p erstes)
  275.            (list 'APPEND erstes)
  276.            erstes
  277.         ))
  278.         ((and (consp weiteres) (eq (first weiteres) 'append))
  279.          ; (APPEND expr (APPEND . rest)) -> (APPEND expr . rest)
  280.          (list* 'APPEND erstes (rest weiteres)) )
  281.         (t (list 'APPEND erstes weiteres))
  282. ) )
  283.  
  284. ; Liefert die Form, die das Cons-Ergebnis der Formen erstes und weiteres
  285. ; ergibt.
  286. (defun backquote-cons (erstes weiteres)
  287.   ; (CONS erstes weiteres) vereinfachen
  288.   (cond ((and (constantp erstes) (constantp weiteres))
  289.          ; beide Teile konstant -> sofort zusammensetzen
  290.          (setq erstes (eval erstes))
  291.          (setq weiteres (eval weiteres))
  292.          (list 'QUOTE
  293.            (cons (if (eq erstes 'UNQUOTE) 'UNQUOTE-DUMMY erstes) weiteres)
  294.         ))
  295.         ((null weiteres)
  296.          ; (CONS expr NIL) -> (LIST expr)
  297.          (list 'LIST erstes)
  298.         )
  299.         ((atom weiteres)
  300.          (list 'CONS erstes weiteres) ; ohne Vereinfachung
  301.         )
  302.         ((eq (first weiteres) 'LIST)
  303.          ; (CONS expr (LIST . rest)) -> (LIST expr . rest)
  304.          (list* 'LIST erstes (rest weiteres))
  305.         )
  306.         ((or (eq (first weiteres) 'LIST*) (eq (first weiteres) 'CONS))
  307.          ; (CONS expr (LIST* . rest)) -> (LIST* expr . rest)
  308.          ; (CONS expr1 (CONS expr2 expr3)) -> (LIST* expr1 expr2 expr3)
  309.          (list* 'LIST* erstes (rest weiteres))
  310.         )
  311.         (t (list 'CONS erstes weiteres)) ; ohne Vereinfachung
  312. ) )
  313.  
  314.